home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / lib / srfi-69.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  11.0 KB  |  313 lines
  1. ;; Copyright (C) Panu Kalliokoski (2005). All Rights Reserved.
  2. ;; 
  3. ;; Permission is hereby granted, free of charge, to any person obtaining a
  4. ;; copy of this software and associated documentation files (the
  5. ;; "Software"), to deal in the Software without restriction, including
  6. ;; without limitation the rights to use, copy, modify, merge, publish,
  7. ;; distribute, sublicense, and/or sell copies of the Software, and to
  8. ;; permit persons to whom the Software is furnished to do so, subject to
  9. ;; the following conditions:
  10. ;; 
  11. ;; The above copyright notice and this permission notice shall be included
  12. ;; in all copies or substantial portions of the Software.
  13. ;; 
  14. ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  15. ;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  16. ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  17. ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  18. ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  19. ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  20. ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 
  21.  
  22. ;; Latest sources:
  23. ;;
  24. ;; http://members.sange.fi/~atehwa/vc/r+d/guse/srfi/hash-srfi.ss
  25. ;; http://members.sange.fi/~atehwa/vc/r+d/guse/srfi/test-hash.ss
  26.  
  27.  
  28. ;; ChangeLog
  29. ;;
  30. ;; 2007-07-23 yamaken   - Imported from
  31. ;;                        http://srfi.schemers.org/srfi-69/srfi-69.html
  32. ;;                        and adapted to SigScheme
  33.  
  34.  
  35. ;;
  36. ;; SigScheme adaptation
  37. ;;
  38.  
  39. (require-extension (srfi 9 23))
  40.  
  41. (define inexact? (lambda (x) #f))
  42. (define real?    inexact?)
  43.  
  44. (define expt
  45.   (lambda (x y)
  46.     (let rec ((res 1)
  47.               (cnt y))
  48.       (if (zero? cnt)
  49.           res
  50.           (rec (* res x) (- cnt 1))))))
  51.  
  52. ;;
  53. ;; Main implementation
  54. ;;
  55.  
  56. ;; This implementation relies on SRFI-9 for distinctness of the hash table
  57. ;; type, and on SRFI-23 for error reporting.  Otherwise, the implementation
  58. ;; is pure R5RS.
  59.  
  60. (define *default-bound* (- (expt 2 29) 3))
  61.  
  62. (define (%string-hash s ch-conv bound)
  63.   (let ((hash 31)
  64.     (len (string-length s)))
  65.     (do ((index 0 (+ index 1)))
  66.       ((>= index len) (modulo hash bound))
  67.       (set! hash (modulo (+ (* 37 hash)
  68.                 (char->integer (ch-conv (string-ref s index))))
  69.              *default-bound*)))))
  70.  
  71. (define (string-hash s . maybe-bound)
  72.   (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
  73.     (%string-hash s (lambda (x) x) bound)))
  74.  
  75. (define (string-ci-hash s . maybe-bound)
  76.   (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
  77.     (%string-hash s char-downcase bound)))
  78.  
  79. (define (symbol-hash s . maybe-bound)
  80.   (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
  81.     (%string-hash (symbol->string s) (lambda (x) x) bound)))
  82.  
  83. (define (hash obj . maybe-bound)
  84.   (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
  85.     (cond ((integer? obj) (modulo obj bound))
  86.       ((string? obj) (string-hash obj bound))
  87.       ((symbol? obj) (symbol-hash obj bound))
  88.       ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound))
  89.       ((number? obj)
  90.        (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj))))
  91.            bound))
  92.       ((char? obj) (modulo (char->integer obj) bound))
  93.       ((vector? obj) (vector-hash obj bound))
  94.       ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj))))
  95.                    bound))
  96.       ((null? obj) 0)
  97.       ((not obj) 0)
  98.       ((procedure? obj) (error "hash: procedures cannot be hashed" obj))
  99.       (else 1))))
  100.  
  101. (define hash-by-identity hash)
  102.  
  103. (define (vector-hash v bound)
  104.   (let ((hashvalue 571)
  105.     (len (vector-length v)))
  106.     (do ((index 0 (+ index 1)))
  107.       ((>= index len) (modulo hashvalue bound))
  108.       (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index)))
  109.                   *default-bound*)))))
  110.  
  111. (define %make-hash-node cons)
  112. (define %hash-node-set-value! set-cdr!)
  113. (define %hash-node-key car)
  114. (define %hash-node-value cdr)
  115.  
  116. (define-record-type <srfi-hash-table>
  117.   (%make-hash-table size hash compare associate entries)
  118.   hash-table?
  119.   (size hash-table-size hash-table-set-size!)
  120.   (hash hash-table-hash-function)
  121.   (compare hash-table-equivalence-function)
  122.   (associate hash-table-association-function)
  123.   (entries hash-table-entries hash-table-set-entries!))
  124.  
  125. (define *default-table-size* 64)
  126.  
  127. (define (appropriate-hash-function-for comparison)
  128.   (or (and (eq? comparison eq?) hash-by-identity)
  129.       (and (eq? comparison string=?) string-hash)
  130.       (and (eq? comparison string-ci=?) string-ci-hash)
  131.       hash))
  132.  
  133. (define (make-hash-table . args)
  134.   (let* ((comparison (if (null? args) equal? (car args)))
  135.      (hash
  136.        (if (or (null? args) (null? (cdr args)))
  137.          (appropriate-hash-function-for comparison) (cadr args)))
  138.      (size
  139.        (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
  140.          *default-table-size* (caddr args)))
  141.      (association
  142.        (or (and (eq? comparison eq?) assq)
  143.            (and (eq? comparison eqv?) assv)
  144.            (and (eq? comparison equal?) assoc)
  145.            (letrec
  146.          ((associate
  147.             (lambda (val alist)
  148.               (cond ((null? alist) #f)
  149.                 ((comparison val (caar alist)) (car alist))
  150.                 (else (associate val (cdr alist)))))))
  151.          associate))))
  152.     (%make-hash-table 0 hash comparison association (make-vector size '()))))
  153.  
  154. (define (make-hash-table-maker comp hash)
  155.   (lambda args (apply make-hash-table (cons comp (cons hash args)))))
  156. (define make-symbol-hash-table
  157.   (make-hash-table-maker eq? symbol-hash))
  158. (define make-string-hash-table
  159.   (make-hash-table-maker string=? string-hash))
  160. (define make-string-ci-hash-table
  161.   (make-hash-table-maker string-ci=? string-ci-hash))
  162. (define make-integer-hash-table
  163.   (make-hash-table-maker = modulo))
  164.  
  165. (define (%hash-table-hash hash-table key)
  166.   ((hash-table-hash-function hash-table)
  167.      key (vector-length (hash-table-entries hash-table))))
  168.  
  169. (define (%hash-table-find entries associate hash key)
  170.   (associate key (vector-ref entries hash)))
  171.  
  172. (define (%hash-table-add! entries hash key value)
  173.   (vector-set! entries hash
  174.            (cons (%make-hash-node key value)
  175.              (vector-ref entries hash))))
  176.  
  177. (define (%hash-table-delete! entries compare hash key)
  178.   (let ((entrylist (vector-ref entries hash)))
  179.     (cond ((null? entrylist) #f)
  180.       ((compare key (caar entrylist))
  181.        (vector-set! entries hash (cdr entrylist)) #t)
  182.       (else
  183.         (let loop ((current (cdr entrylist)) (previous entrylist))
  184.           (cond ((null? current) #f)
  185.             ((compare key (caar current))
  186.              (set-cdr! previous (cdr current)) #t)
  187.             (else (loop (cdr current) current))))))))
  188.  
  189. (define (%hash-table-walk proc entries)
  190.   (do ((index (- (vector-length entries) 1) (- index 1)))
  191.     ((< index 0)) (for-each proc (vector-ref entries index))))
  192.  
  193. (define (%hash-table-maybe-resize! hash-table)
  194.   (let* ((old-entries (hash-table-entries hash-table))
  195.      (hash-length (vector-length old-entries)))
  196.     (if (> (hash-table-size hash-table) hash-length)
  197.       (let* ((new-length (* 2 hash-length))
  198.          (new-entries (make-vector new-length '()))
  199.          (hash (hash-table-hash-function hash-table)))
  200.     (%hash-table-walk
  201.       (lambda (node)
  202.         (%hash-table-add! new-entries
  203.                   (hash (%hash-node-key node) new-length)
  204.                   (%hash-node-key node) (%hash-node-value node)))
  205.       old-entries)
  206.     (hash-table-set-entries! hash-table new-entries)))))
  207.  
  208. (define (hash-table-ref hash-table key . maybe-default)
  209.   (cond ((%hash-table-find (hash-table-entries hash-table)
  210.                (hash-table-association-function hash-table)
  211.                (%hash-table-hash hash-table key) key)
  212.      => %hash-node-value)
  213.     ((null? maybe-default)
  214.      (error "hash-table-ref: no value associated with" key))
  215.     (else ((car maybe-default)))))
  216.  
  217. (define (hash-table-ref/default hash-table key default)
  218.   (hash-table-ref hash-table key (lambda () default)))
  219.  
  220. (define (hash-table-set! hash-table key value)
  221.   (let ((hash (%hash-table-hash hash-table key))
  222.     (entries (hash-table-entries hash-table)))
  223.     (cond ((%hash-table-find entries
  224.                  (hash-table-association-function hash-table)
  225.                  hash key)
  226.        => (lambda (node) (%hash-node-set-value! node value)))
  227.       (else (%hash-table-add! entries hash key value)
  228.         (hash-table-set-size! hash-table
  229.                        (+ 1 (hash-table-size hash-table)))
  230.         (%hash-table-maybe-resize! hash-table)))))
  231.  
  232. (define (hash-table-update! hash-table key function . maybe-default)
  233.   (let ((hash (%hash-table-hash hash-table key))
  234.     (entries (hash-table-entries hash-table)))
  235.     (cond ((%hash-table-find entries
  236.                  (hash-table-association-function hash-table)
  237.                  hash key)
  238.        => (lambda (node)
  239.             (%hash-node-set-value!
  240.           node (function (%hash-node-value node)))))
  241.       ((null? maybe-default)
  242.        (error "hash-table-update!: no value exists for key" key))
  243.       (else (%hash-table-add! entries hash key
  244.                   (function ((car maybe-default))))
  245.         (hash-table-set-size! hash-table
  246.                        (+ 1 (hash-table-size hash-table)))
  247.         (%hash-table-maybe-resize! hash-table)))))
  248.  
  249. (define (hash-table-update!/default hash-table key function default)
  250.   (hash-table-update! hash-table key function (lambda () default)))
  251.  
  252. (define (hash-table-delete! hash-table key)
  253.   (if (%hash-table-delete! (hash-table-entries hash-table)
  254.                (hash-table-equivalence-function hash-table)
  255.                (%hash-table-hash hash-table key) key)
  256.     (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1))))
  257.  
  258. (define (hash-table-exists? hash-table key)
  259.   (and (%hash-table-find (hash-table-entries hash-table)
  260.              (hash-table-association-function hash-table)
  261.              (%hash-table-hash hash-table key) key) #t))
  262.  
  263. (define (hash-table-walk hash-table proc)
  264.   (%hash-table-walk
  265.     (lambda (node) (proc (%hash-node-key node) (%hash-node-value node)))
  266.     (hash-table-entries hash-table)))
  267.  
  268. (define (hash-table-fold hash-table f acc)
  269.   (hash-table-walk hash-table 
  270.                (lambda (key value) (set! acc (f key value acc))))
  271.   acc)
  272.  
  273. (define (alist->hash-table alist . args)
  274.   (let* ((comparison (if (null? args) equal? (car args)))
  275.      (hash
  276.        (if (or (null? args) (null? (cdr args)))
  277.          (appropriate-hash-function-for comparison) (cadr args)))
  278.      (size
  279.        (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
  280.          (max *default-table-size* (* 2 (length alist))) (caddr args)))
  281.      (hash-table (make-hash-table comparison hash size)))
  282.     (for-each
  283.       (lambda (elem)
  284.     (hash-table-update!/default
  285.       hash-table (car elem) (lambda (x) x) (cdr elem)))
  286.       alist)
  287.     hash-table))
  288.  
  289. (define (hash-table->alist hash-table)
  290.   (hash-table-fold hash-table
  291.            (lambda (key val acc) (cons (cons key val) acc)) '()))
  292.  
  293. (define (hash-table-copy hash-table)
  294.   (let ((new (make-hash-table (hash-table-equivalence-function hash-table)
  295.                     (hash-table-hash-function hash-table)
  296.                   (max *default-table-size*
  297.                    (* 2 (hash-table-size hash-table))))))
  298.     (hash-table-walk hash-table
  299.              (lambda (key value) (hash-table-set! new key value)))
  300.     new))
  301.  
  302. (define (hash-table-merge! hash-table1 hash-table2)
  303.   (hash-table-walk
  304.     hash-table2
  305.     (lambda (key value) (hash-table-set! hash-table1 key value)))
  306.   hash-table1)
  307.  
  308. (define (hash-table-keys hash-table)
  309.   (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '()))
  310.  
  311. (define (hash-table-values hash-table)
  312.   (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '()))
  313.